perm filename T1X.OL3[M11,LCS] blob
sn#409407 filedate 1979-01-09 generic text, type T, neo UTF8
C*** 33 PARAMS SEEMS TO BE LIMIT IN THIS VERSION. (30 IN 'SCORE') *****
SUBROUTINE TRANS(JJJ)
CIN DIMENSION IINS(108)
C W(35) FOR PARAMETERS
CIN COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,4),K
COMMON /TR/I(80),RX(100),JX(100),LX(12),K
1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
1,ENDX,J /KNAM/IPLAY,JFLNM,IOPEN,JPLAY /IFIRST/IFIRST,IDT
1 /INST/INST(27)
1 /WDZ/WDZ(14),JWD(12)
COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
COMMON LL /P/W(1) /CONV/ICONV /FQDR/FQDR(28,27),INSN
INTEGER FQDR
C****************CHECK NEAR HERE FOR NEEDED CHANGES **************
CXX DOUBLE PRECISION IDBL,JANP,JBLA,JFLNM,IDBG,
CXX 1 INST,INAM,JSEMI,ICOLON
EQUIVALENCE (LESS,LX(9)),(IX,IXJ,JX),(RX2,RX(3)),
1(P2,P(2)),(RX3,RX(5)),(I3,I(3)),(ISEMI,LX(2))
1,(IBLA,LX(1)),(IAST,LX(3)),(IINS,INST)
1,(IAROW,LX(7)),(W1,W),(W3,W(3)),(W2,W(2))
CXX DATA LX/' ',';', '*','/','-','+'
CXX 1,'←','=', '<', ',', '(', ')'/, IFIRST/-1/,IOPEN/-1/
C****************CHECK NEAR HERE FOR NEEDED CHANGES **************
DATA LX/' ',';', '*','/','-','+'
1,"575004020100,'=','<' ,',' ,'(', ')'/, IOPEN/-1/
1 , IDOT/'.'/, IDEV/1/,JPRNT/1/,JWRT/-1/,JFLNM/'TRNS'/
1,JBLA/' '/,IDBG/'# '/,JDBG/'#'/,JSEMI/';'/
C*** THIS VERSION STARTS OUT WITH DEFAULT OUTPUT TO FILE: TRNS.DAT
DATA RMAG/.0512/,INUM/0/,SRATE/12800./,RNCHN/1./
1,IEXP/'!'/,JANP/'& '/
1,IANP/'&'/,ICONV/-1/,ICOLON/':'/
1,IALT/"765004020100/
CXX 1,IALT/'"'/
C ICONV=-1 MEANS WRITE A SOUND FILE. (=0 = WRITE A FILE FOR 'SMPLS' PROG.)
GO TO (555,5002) JJJ
555 LLLL=0
401 IF(IFIRST)404, 5,600
404 IGEN=-1
JPLAY=0
IF(INUM.NE.0)GO TO 30
DO 411 K=1,27
411 INST(K)=0
CIN DO 411 K=1,108
CIN411 IINS(K)=0
C ZERO OUT INSTR. NAME ARRAY.
30 IPLAY=0
ENDX=0
JSEM=0
INS=-1
402 IDEV=1
TYPE 1
1 FORMAT(' INPUT? '$)
100 FORMAT(' >'$)
2 FORMAT(A4)
ACCEPT 2,IDBL
C IDBL WILL HAVE TO BE DOUBLE PREC. ON PDP11 ************
IF(IDBL.NE.JBLA)GO TO 400
IDEV=5
GO TO 5
400 IF(IDBL.EQ.JANP)GO TO 603
C!*** & IS PRNT-NOPRNT FLIPFLOP
IF(IDBL.NE.IDBG)GO TO 410
4448 TYPE 4023
4446 TYPE 4445
ACCEPT 51,KI
IF(KI.EQ.0)GO TO 4022
IF(KI.GT.0)GO TO 4447
C******** THIS STUFF FOR DIAGNOSIS
IF(KI.EQ.-1)TYPE 2325,IGEN
IF(KI.EQ.-2)TYPE 2325,IPRNT
IF(KI.EQ.-3)TYPE 2325,IPLAY
IF(KI.EQ.-4)TYPE 2325,JSEM
IF(KI.EQ.-5)TYPE 2325,J
IF(KI.EQ.-6)TYPE 2325,MM
GO TO 4446
4022 IF(IDEV.EQ.1)GO TO 402
C GO BACK TO 'INPUT' OR '>'
GO TO 502
C THIS WILL TYPE OUT ELEMENTS OF LX ARRAY.
4447 TYPE 2326,LX(KI)
TYPE 2325,LX(KI)
GO TO 4446
4445 FORMAT(' TYPE LX NUMB. '$)
4023 FORMAT(' IGEN, IPRNT, IPLAY, JSEM, J, MM'/)
2324 FORMAT(1X12F/)
2325 FORMAT(1X5I/)
2326 FORMAT(1X80A1)
410 IF(IDBL.EQ.ICOLON)CALL EXIT
C TYPE ':' TO EXIT AND CLOSE ALL FILES.
CALL IFILE(1,IDBL)
CX CALL OPEN(1,IDBL,0,'RDO')
4 FORMAT(80A1)
C****************
CX TYPE 2325,JSEM
CX TYPE 2325,J
CX TYPE 2325,MM
5 IF(JSEM.AND.J.LT.MM)GO TO 305
IF(JSEM.NE.99)GO TO 502
IFIRST=IFIRST+10
GO TO 555
600 JSEM=0
IFIRST=IFIRST-10
INS=-1
502 IF(IDEV.NE.5)GO TO 601
CX TYPE 2325,IDEV
C*******************************
IF(KSEM.EQ.0)GO TO 503
C KSEM=-1=WE'λE JUST SEEN A SEMICOLON, =0=READ MORE STUFF ON NEXT LINE.
IF(IGEN.NE.2)IGEN=-1
503 TYPE 100
C*******************************
601 READ(IDEV,4,END=404)I
IF(I1.EQ.ICOLON)CALL EXIT
C TYPE ':' TO EXIT AND CLOSE FILES.
IF(IDEV.EQ.5)GO TO 1232
KI=80
1233 IF(I(KI).NE.IBLA)GO TO 1234
KI=KI-1
IF(KI.GT.0)GO TO 1233
1234 IF(JPRNT.LT.0)TYPE 2326,(I(IJI),IJI=1,KI)
GO TO 602
1232 DO 1235 K=1,80
1235 IF(I(K).NE.IBLA)GO TO 1236
C!**** USE BLANK (<CR>) TO RETURN TO 'INPUT?' (UNLESS IN PLAY LOOP)
IF(JPLAY.GE.0)GO TO 404
GO TO 503
1236 IF(I(1).EQ.JDBG)GO TO 4448
C TYPE '#' FOR SOME DEBUGGING
IF(I(1).NE.IANP)GO TO 602
C!*** &=TYPE OUT MUS5 NUMBERS
603 JPRNT=-JPRNT
IF(IDEV.EQ.1)GO TO 402
C IDEV=1 = GO BACK TO 'INPUT'
GO TO 502
602 IF(I(1).NE.IALT)GO TO 408
C!***<ALT> FOR INSTRUMENT LIST; ALT IS DBL QUOTE IN THIS PROG. FOR NOW.
DO 606 K=1,INUM
CC JK=NPAR(K)-2
JK=INSNUM(K)
MM=NPAR(JK)-2
606 TYPE 607,INST(K),JK,MM
CIN606 TYPE 607,(INST(K,L),L=1,4),JK,NPAR(JK)
CC606 TYPE 607,(INST(K,L),L=1,4),INSNUM(K),JK
GO TO 5
607 FORMAT(1X,A4,' NUM=',I2,' PARAMS=',I2)
CIN607 FORMAT(1X,4A1,' NUM=',I2,' PARAMS=',I2)
C!*** PRINTS INST INFO.
408 IF(I(1).NE.IEXP)GO TO 1408
C TRIGGERS ICONV FLIPFLOP
IF(ICONV)GO TO 2408
ICONV=-1
TYPE 3408
GO TO 502
2408 ICONV=0
TYPE 4408
GO TO 502
3408 FORMAT(' OUTPUT=TEST.SND'/)
4408 FORMAT(' OUTPUT=TEST.DAT'/)
1408 DO 407 K=1,100
407 JX(K)=IBLA
DO 405 K=1,80
IF(I(K).EQ.LESS)GO TO 5
405 IF(I(K).NE.IBLA)GO TO 406
GO TO 5
406 MM=0
DO 4061 J=2,100,2
4061 RX(J)=0
J=-1
IPRNT=0
119 JI=0
9 M=0
N=JI+1
6 JI=JI+1
KCHAR=I(JI)
DO 7 L=1,12
7 IF(KCHAR.EQ.LX(L))GO TO 8
M=M+1
GO TO 6
C!**** NO STRING CAN EXCEED 10 CHARS.
8 IF(KCHAR.EQ.LESS)GO TO 15
IF(M.EQ.0)GO TO 140
KSEM=0
C KSEM WILL = -1 WHEN WE HIT NEXT SEMICOLON.
IF(M.GT.10)M=10
MM=MM+1
IF(MM.LE.50)GO TO 88
TYPE 888,(I(JJ),JJ=N,N+9)
STOP
888 FORMAT(' LINE TOO LONG -- ',10A1)
88 JJ=I(N)
IF(JJ.GT.'9')GO TO 16
IF(JJ.NE.IDOT.AND.JJ.LT.'0')GO TO 16
CXX IF(JJ.GT.8249)GO TO 16
CXX IF(JJ.NE.IDOT.AND.JJ.LT.8240)GO TO 16
C**** 8240='0' 8249='9'
C!***** JUMP IF 1ST CHAR. IS A LETTER.
Y=0
DOT=10.
DO 18 JK=N,N+M-1
JA=I(JK)
IF(JA.NE.IDOT)GO TO 17
DOT=.1
GO TO 18
CXX17 X=JA-8240
17 X=NASCI(JA)
C!**** CHANGE ASCII INTO NUMBER
IF(DOT.LT.1)GO TO 19
Y=Y*DOT+X
GO TO 18
19 Y=Y+X*DOT
DOT=DOT/10.
18 CONTINUE
RX(MM*2-1)=Y
RX(MM*2)=-9999.0
GO TO 140
16 JK=MM*2-1
CX JX(JK)=0
CX RX(JK)=0
CX JX(JK+1)=0
CX RX(JK+1)=0
CALL MPACK(M,I(N),JX(JK),N)
C N=CURRENT POINTER TO I ARRAY - USED LATER TO LOCATE INST. NAMES.
IJ=JX(JK)
IF(IJ.GE.0)GO TO 144
C IF IJ < 0, THEN IT'S A LETTER
JX(MM*2)=M
C SAVE THE WD CNT OF POTENTIAL INST. NAME.
GO TO 143
144 IF(IJ.NE.408)GO TO 140
TYPE 244,WDZ,JWD
GO TO 503
244 FORMAT(15(1XA4))
140 IF(IJ.NE.413)GO TO 143
INS=1
C!*** 'UNIT GENERATOR' IS RESERVED FOR NEW ONES.
GO TO 5
143 IF(KCHAR.EQ.IBLA)GO TO 10
IF(L.EQ.8)KCHAR=IAROW
C!::: CHANGE = INTO ←
IF(KCHAR.NE.ISEMI)GO TO 141
C NEXT JUMPS IF DUPLICATE SEMICOLON FOUND.
IF(KSEM.LT.0)GO TO 10
C NOW WE'VE SEEN A SEMICOLON
KSEM=-1
141 MM=MM+1
KI=MM*2-1
JX(KI)=KCHAR
10 IF(I(JI+1).NE.IBLA)GO TO 11
JI=JI+1
GO TO 10
11 IF(JI.LT.80)GO TO 9
C NOW WE HAVE ALL ITEMS IN IX ARRAY
IF(MM.GT.1)GO TO 15
C CATCH 'WORD ;' AT END OF LINE
IF(KSEM.LT.0)GO TO 15
IF(M.EQ.0)GO TO 5
15 MM=MM*2
IF(IJ.NE.404)GO TO 142
CCC IF(IXJ.NE.KPRNT)GO TO 142
INS=-1
C!***** FOR 'PRINT'
IPRNT=-1
142 J=-1
IF(INS.LT.0)GO TO 305
IF(INS.EQ.2)GO TO 305
MM=0
INS=-1
C!***** NOW INITIALIZATION COMPLETE
GO TO 5
50 IF(IGEN)308,309,309
309 LL=LL-1
IF(JSEM.LE.0.AND.IGEN.EQ.1)IGEN=-1
C!*** FOUND 'END'
GO TO 59
308 W1=1
IK=W2
IF(LL.GT.NPAR(IK))GO TO 56
54 IF(LL.LT.3)LL=3
DO 55 K=LL,NPAR(IK)
55 W(K)=P(K-2)
C!***** GET INFO ALREADY IN PARAMS
56 DO 57 K=3,LL
57 P(K-2)=W(K)
C!**** FILL UP P LIST AGAIN
X=W3
C!*** EXCHANGE W2 AND W3, ACTION TIME, INST #
W3=W2
W2=X
58 LL=NPAR(IK)
DO 52 K=5,LL
KI=FQDR(K-4,IK)
IF(KI)53,52,2352
2352 W(K)=RMAG/W(K)
GO TO 52
53 W(K)=RMAG*W(K)
52 CONTINUE
IF(ENDX.LT.W2+P2)ENDX=W2+P2
59 IF(W1.NE.2.)GO TO 592
IF(LL.EQ.2)GO TO 597
C JUMP IF 'END' OF INS DEF.
IF(LL.NE.3)GO TO 595
C JUMP IF NOT AN INST DEF.
PSV=0
SV=35
C EXPLAIN USE OF STORAGE PARAMS!!
INSN=W3
C INS DEF NUM.
CC JINS=INUM
C LIST OF INST NAMES MUST FOLLOW 'INS 0 N;' !!!ALWAYS!!!
CIN596 INUM=INUM+1
CIN596 READ(IDEV,2)INST(INUM)
596 READ(IDEV,2,END=587)INAM
IF(INAM.EQ.JSEMI)GO TO 595
C LIST OF INST NAMES TERMINATES WITH ';'.
DO 588 K=1,INUM
IF(INAM.NE.INST(K))GO TO 588
INST(K)=INAM
INSNUM(K)=INSN
GO TO 589
587 PAUSE 'MISSING SEMICOLON'
588 CONTINUE
INUM=INUM+1
INST(INUM)=INAM
CIN READ(IDEV,4)(INST(INUM,K),K=1,4)
CIN IF(INST(INUM,1).EQ.ISEMI)GO TO 599
C LIST OF INST NAMES TERMINATES WITH ';'.
INSNUM(INUM)=INSN
589 IF(JPRNT)TYPE 244,INAM
CIN IF(JPRNT)TYPE 2326,(INST(INUM,K),K=1,4)
GO TO 596
CIN599 INUM=INUM-1
595 DO 593 K=3,LL
X=W(K)
IF(X.LT.0.OR.X.GT.100)GO TO 593
IF(X.GT.PSV)PSV=X
C CHECK FOR OVERLAPPING PARAM NUMS.
593 CONTINUE
IF(W3.NE.102.AND.W3.NE.105.AND.W3.NE.111.AND.W3.NE.104
1 .AND.W3.NE.115)GO TO 592
C 115=NOS, 102=OSC, 105=ENV, 104=RAI (3 STOR. LOCS), 111=RAH (2 STOR. LOCS)
C NEXT SETS UP STORAGE LOCATIONS FOR OSC, ENV, RAN, AND RAH.
X=W3
594 LL=LL+1
W(LL)=SV
SV=SV-1
C DECREMENT THE HIGH PARAM NUM.
IF(SV.LT.PSV)PAUSE 'PARAMETER OVERLAP'
CIN IF(SV.LT.PSV)CALL ERROR(5)
C IF STORAGE PARAM NUM. OVERLAPS WITH INSTS/'S PARAMS = ERROR
IF(X.NE.111.AND.X.NE.104)GO TO 592
IF(X.EQ.111)X=0
IF(X.EQ.104)X=111
GO TO 594
597 NPAR(INSN)=PSV
C SAVE THE HIGHEST PARAM NUM.
592 IF(JPRNT.GE.0)GO TO 591
TYPE 51,LL,(W(K),K=1,LL)
CXX WRITE(22,51)LL,(W(K),K=1,LL)
C ABOVE WRITES ONTO FILE 'D.DAT' *** TEMPORARY FOR DEBUGGING.
591 IF(JWRT.GE.0)GO TO 500
CZZ IF(IOPEN.LT.0)CALL OFILE(21,JFLNM)
CXX IF(IOPEN.LT.0)CALL OPEN(21,JFLNM,0,'NEW',,,'UNF')
C OPENS FILE, IF NOT ALREADY OPEN.
CZZ WRITE(21)LL,(W(K),K=1,LL)
IDT=2
RETURN
5002 IOPEN=0
500 IFIRST=0
IF(IGEN.EQ.0)IGEN=-1
IF(W1.NE.6)GO TO 555
RETURN
C W1=6 = 'FINISH;' [W ARRAY IS EQUIV. TO P ARRAY IN MUSIC5]
306 IF(JPRNT.LT.0)TYPE 1307,(W(K),K=1,LL-1)
IF(JPRNT.GT.0)TYPE 307,(W(K),K=1,LL-1)
IPRNT=0
C!** RESET NO-PRNT FLAG
JSEM=0
C!** RESET SEMICOLON FLAG
INS=-1
IF(J.GE.MM-1)GO TO 5
C!** GO READ ANOTHER LINE
305 CALL MSCAN
IF(KSEM.LT.0)GO TO 303
JSEM=1
C FOR CONTINUATION LINES (NO SEMICOLON AT END OF LINE, GO TO NEXT)
KSEM=0
303 IF(IPRNT.LT.0)GO TO 306
IF(J.LT.MM)JSEM=-1
C!**** STILL MORE CHARS TO COME.
IF(ENDX.GE.0)GO TO 302
ENDX=0
GO TO 500
302 IF(JSEM)50,5,5
51 FORMAT(I3,35F10.3/)
307 FORMAT('+',F8.2,$)
1307 FORMAT(F10.3)
END
FUNCTION NASCI(N)
DATA IEX/536870912/,IZERO/'0'/
C THIS BIG NUMBER MUST BE CHANGED ON PDP11***************
NASCI=(N-IZERO)/IEX
C CONVERTS SINGLE ASCII CHARACTER TO INTEGER.
END
SUBROUTINE CLOSIT(LL,W)
COMMON /KNAM/B,C,IOPEN
IOPEN=-1
RETURN
END